Visual Basic Controls/Visual Basic Controls.iso/vbcontrol/sgwnd10/codebloc.cls

Visual Basic class definition | 1998-08-15 | 9.2 KB | 268 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CodeBlock"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"No"
Attribute VB_Ext_KEY = "Member0" ,"Location"
Attribute VB_Ext_KEY = "Member1" ,"Parameters"
Option Explicit

Private mvarName As String
Private mvarLocation As Location
Private mvarTemplate As String
Private mvarParameters As Parameters


Const skeyCodeBlock = "{CodeBlock}"
Const skeyEndCode = "{EndCode}"
Const skeyCode = "{Code}"
Const skeyName = "{Name}"
Const skeyLocation = "{Location}"
Const sparLeft = "["
Const sparRight = "]"


Private Sub ExpandString(ByRef s$)
    If Not (mvarParameters Is Nothing) Then
        Dim par As Parameter
        For Each par In mvarParameters
            Dim sPar$
            sPar = sparLeft & par.name & sparRight
            Str_ReplaceAll s, sPar, par.Value
        Next
    End If
End Sub

Private Function ItemValue(sText$, sName$)
    ItemValue = ""

    Dim pos&
    pos = InStr(sText, sName)
    If (pos > 0) Then
        pos = InStr(pos, sText, "=")
        If (pos > 0) Then
            Dim endPos&
            endPos = InStr(pos + 1, sText, vbCrLf)
            ItemValue = Str_Trim(Mid(sText, pos + 1, endPos - pos - 1))
        End If
    End If
End Function

Friend Sub Initialize(sCodeBlock$, params As Parameters)

    Set mvarLocation = Nothing
    Set mvarLocation = New Location
    Set mvarParameters = params

    ' Find block name and location
    mvarName = ItemValue(sCodeBlock, skeyName)
    Dim sLocation$
    sLocation = ItemValue(sCodeBlock, skeyLocation)
    ExpandString sLocation
    mvarLocation.Initialize sLocation

    ' Find code
    mvarTemplate = ""
    Dim nCodeStart&, nCodeEnd&
    nCodeStart = InStr(1, sCodeBlock, skeyCode)
    If (nCodeStart = 0) Then Exit Sub
    nCodeStart = nCodeStart + Len(skeyCode)
    nCodeEnd = InStr(nCodeStart, sCodeBlock, skeyEndCode)
    If (nCodeEnd < nCodeStart) Then Exit Sub
    nCodeEnd = nCodeEnd - 1
    mvarTemplate = Str_TrimEx(Mid(sCodeBlock, nCodeStart, nCodeEnd - nCodeStart), Chr(10) & Chr(13))
End Sub

Private Sub Class_Initialize()
    Set mvarParameters = Nothing
    Set mvarLocation = New Location
End Sub

Private Sub Class_Terminate()
    Set mvarParameters = Nothing
    Set mvarLocation = Nothing
End Sub

Public Property Get Template() As String
Attribute Template.VB_Description = "Original temlate code"
    Template = mvarTemplate
End Property

Public Property Get Location() As Object
Attribute Location.VB_Description = "Location of the code block"
    Set Location = mvarLocation
End Property

Public Property Get name() As String
Attribute name.VB_Description = "Code block name"
    name = mvarName
End Property

Public Function ExpandTemplate() As String
    ExpandTemplate = mvarTemplate
    ExpandString ExpandTemplate
End Function

Public Property Get InsertPosition(code As CodeModule) As Long
    On Error GoTo Error_

    InsertPosition = 0
    If (code Is Nothing) Then Exit Property

    With mvarLocation
        Select Case .Section
            Case sectGlobal
                InsertPosition = 1
                Select Case .Position
                    Case posEnd: InsertPosition = code.CountOfDeclarationLines + 1
                    Case posAbsolute: InsertPosition = .LineNumber
                End Select

            Case sectProc
                On Error Resume Next
                InsertPosition = 0
                InsertPosition = code.ProcBodyLine(.ProcName, vbext_pk_Proc)
                On Error GoTo Error_
                If (InsertPosition > 0) Then
                    Select Case .Position
                        Case posBegin: InsertPosition = InsertPosition + 1
                        Case posEnd: InsertPosition = InsertPosition + code.ProcCountLines(.ProcName, vbext_pk_Proc) - 2
                        Case posAbsolute: InsertPosition = InsertPosition + .LineNumber
                    End Select
                Else
                    ' Procedure does not exist.
                End If

            Case sectEvent
                Dim sProcName
                sProcName = .ObjectName & "_" & .EventName
                On Error Resume Next
                InsertPosition = 0
                InsertPosition = code.ProcBodyLine(sProcName, vbext_pk_Proc)
                On Error GoTo Error_
                If (InsertPosition > 0) Then
                    Select Case .Position
                        Case posBegin: InsertPosition = InsertPosition + 1
                        Case posEnd: InsertPosition = InsertPosition + code.ProcCountLines(sProcName, vbext_pk_Proc) - 2
                        Case posAbsolute: InsertPosition = InsertPosition + .LineNumber
                    End Select
                Else
                    ' Procedure does not exist.
                End If

            Case sectPropGet, sectPropLet, sectPropSet
                Dim kind As vbext_ProcKind
                Select Case .Section
                    Case sectPropGet: kind = vbext_pk_Get
                    Case sectPropLet: kind = vbext_pk_Let
                    Case sectPropSet: kind = vbext_pk_Set
                End Select

                On Error Resume Next
                InsertPosition = 0
                InsertPosition = code.ProcBodyLine(.ProcName, kind)
                On Error GoTo Error_
                If (InsertPosition > 0) Then
                    Select Case .Position
                        Case posBegin: InsertPosition = InsertPosition + 1
                        Case posEnd: InsertPosition = InsertPosition + code.ProcCountLines(sProcName, vbext_pk_Proc) - 2
                        Case posAbsolute: InsertPosition = InsertPosition + .LineNumber
                    End Select
                Else
                    ' Procedure does not exist.
                End If
        End Select
    End With

    Exit Property
Error_:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Sub EnsureProcExist(code As CodeModule)
    On Error GoTo Error_

    ' Get procedure name
    Dim sProcName$
    Dim kind As vbext_ProcKind
    sProcName = ""
    With mvarLocation
        Select Case .Section
            Case sectGlobal
                kind = vbext_pk_Proc
            Case sectProc:
                kind = vbext_pk_Proc
                sProcName = .ProcName
            Case sectEvent:
                kind = vbext_pk_Proc
                If (.ObjectName <> "") And (.EventName <> "") Then
                    sProcName = .ObjectName & "_" & .EventName
                End If
            Case sectPropGet
                kind = vbext_pk_Get
                sProcName = .ProcName
            Case sectPropLet
                kind = vbext_pk_Let
                sProcName = .ProcName
            Case sectPropSet
                kind = vbext_pk_Set
                sProcName = .ProcName
        End Select

        If (sProcName <> "") Then
            On Error Resume Next
            Dim nLine&
            nLine = 0
            nLine = code.ProcBodyLine(sProcName, kind)
            On Error GoTo Error_
            If (nLine = 0) Then
                ' Procedure does not exist. Create it
                Dim sCode$
                sCode = ""
                Select Case .Section
                    Case sectGlobal
                    Case sectEvent:
                        code.CreateEventProc .EventName, .ObjectName
                    Case sectProc:
                        code.AddFromString "Public Sub " & sProcName & "()" & vbCrLf & "End Sub"
                    Case sectPropGet
                        code.AddFromString "Public Property Get " & sProcName & "() As Variant" & vbCrLf & "End Property"
                    Case sectPropLet
                        code.AddFromString "Public Property Let " & sProcName & "(par)" & vbCrLf & "End Property"
                    Case sectPropSet
                        code.AddFromString "Public Property Set " & sProcName & "(par)" & vbCrLf & "End Property"
                End Select
            End If
        End If
    End With

    Exit Sub
Error_:
   If Err.Number = 57017 Then
      ' Event handler is invalid.
      ' SG Wiindow is not referenced in the VB references list
      Err.Description = "SG Window is not referenced!" & vbCrLf & _
         "Open Project menu and click on the References..." & vbCrLf & _
         "command to add SG Window to the list of the referenced components" & vbCrLf & vbCrLf & _
         "Wizard did not insert all nececcery code!"

   End If
   Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Public Sub InsertCode(code As CodeModule)
    Dim nLine&

    EnsureProcExist code
    nLine = InsertPosition(code)
    If (nLine > 0) Then
        code.InsertLines nLine, ExpandTemplate
    End If
End Sub